home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / emacs / 19.22 / lisp / rmailsort.el < prev    next >
Lisp/Scheme  |  1993-11-23  |  7KB  |  204 lines
  1. ;;; rmailsort.el --- Rmail: sort messages.
  2.  
  3. ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
  6. ;; Version: $Header: /home/fsf/rms/e19/lisp/RCS/rmailsort.el,v 1.16 1993/11/24 08:08:56 rms Exp $
  7. ;; Keywords: mail
  8.  
  9. ;; This file is part of GNU Emacs.
  10.  
  11. ;; GNU Emacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2, or (at your option)
  14. ;; any later version.
  15.  
  16. ;; GNU Emacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Code:
  26.  
  27. (require 'sort)
  28.  
  29. (autoload 'timezone-make-date-sortable "timezone")
  30.  
  31. ;; Sorting messages in Rmail buffer
  32.  
  33. (defun rmail-sort-by-date (reverse)
  34.   "Sort messages of current Rmail file by date.
  35. If prefix argument REVERSE is non-nil, sort them in reverse order."
  36.   (interactive "P")
  37.   (rmail-sort-messages reverse
  38.                (function
  39.             (lambda (msg)
  40.               (rmail-make-date-sortable
  41.                (rmail-fetch-field msg "Date"))))))
  42.  
  43. (defun rmail-sort-by-subject (reverse)
  44.   "Sort messages of current Rmail file by subject.
  45. If prefix argument REVERSE is non-nil, sort them in reverse order."
  46.   (interactive "P")
  47.   (rmail-sort-messages reverse
  48.                (function
  49.             (lambda (msg)
  50.               (let ((key (or (rmail-fetch-field msg "Subject") ""))
  51.                 (case-fold-search t))
  52.                 ;; Remove `Re:'
  53.                 (if (string-match "^\\(re:[ \t]+\\)*" key)
  54.                 (substring key (match-end 0)) key))))))
  55.  
  56. (defun rmail-sort-by-author (reverse)
  57.   "Sort messages of current Rmail file by author.
  58. If prefix argument REVERSE is non-nil, sort them in reverse order."
  59.   (interactive "P")
  60.   (rmail-sort-messages reverse
  61.                (function
  62.             (lambda (msg)
  63.               (downcase    ;Canonical name
  64.                (mail-strip-quoted-names
  65.                 (or (rmail-fetch-field msg "From")
  66.                 (rmail-fetch-field msg "Sender") "")))))))
  67.  
  68. (defun rmail-sort-by-recipient (reverse)
  69.   "Sort messages of current Rmail file by recipient.
  70. If prefix argument REVERSE is non-nil, sort them in reverse order."
  71.   (interactive "P")
  72.   (rmail-sort-messages reverse
  73.                (function
  74.             (lambda (msg)
  75.               (downcase    ;Canonical name
  76.                (mail-strip-quoted-names
  77.                 (or (rmail-fetch-field msg "To")
  78.                 (rmail-fetch-field msg "Apparently-To") "")
  79.                 ))))))
  80.  
  81. (defun rmail-sort-by-correspondent (reverse)
  82.   "Sort messages of current Rmail file by other correspondent.
  83. If prefix argument REVERSE is non-nil, sort them in reverse order."
  84.   (interactive "P")
  85.   (rmail-sort-messages reverse
  86.                (function
  87.             (lambda (msg)
  88.               (rmail-select-correspondent
  89.                msg
  90.                '("From" "Sender" "To" "Apparently-To"))))))
  91.  
  92. (defun rmail-select-correspondent (msg fields)
  93.   (let ((ans ""))
  94.     (while (and fields (string= ans ""))
  95.       (setq ans
  96.         (rmail-dont-reply-to
  97.          (mail-strip-quoted-names
  98.           (or (rmail-fetch-field msg (car fields)) ""))))
  99.       (setq fields (cdr fields)))
  100.     ans))
  101.  
  102. (defun rmail-sort-by-lines (reverse)
  103.   "Sort messages of current Rmail file by number of lines.
  104. If prefix argument REVERSE is non-nil, sort them in reverse order."
  105.   (interactive "P")
  106.   (rmail-sort-messages reverse
  107.                (function
  108.             (lambda (msg)
  109.               (count-lines (rmail-msgbeg msgnum)
  110.                        (rmail-msgend msgnum))))))
  111.  
  112. ;; Basic functions
  113.  
  114. (defun rmail-sort-messages (reverse keyfun)
  115.   "Sort messages of current Rmail file.
  116. If 1st argument REVERSE is non-nil, sort them in reverse order.
  117. 2nd argument KEYFUN is called with a message number, and should return a key."
  118.   (save-excursion
  119.     ;; If we are in a summary buffer, operate on the Rmail buffer.
  120.     (if (eq major-mode 'rmail-summary-mode)
  121.     (set-buffer rmail-buffer))
  122.     (let ((buffer-read-only nil)
  123.       (predicate nil)            ;< or string-lessp
  124.       (sort-lists nil))
  125.       (message "Finding sort keys...")
  126.       (widen)
  127.       (let ((msgnum 1))
  128.     (while (>= rmail-total-messages msgnum)
  129.       (setq sort-lists
  130.         (cons (list (funcall keyfun msgnum) ;Make sorting key
  131.                 (eq rmail-current-message msgnum) ;True if current
  132.                 (aref rmail-message-vector msgnum)
  133.                 (aref rmail-message-vector (1+ msgnum)))
  134.               sort-lists))
  135.       (if (zerop (% msgnum 10))
  136.           (message "Finding sort keys...%d" msgnum))
  137.       (setq msgnum (1+ msgnum))))
  138.       (or reverse (setq sort-lists (nreverse sort-lists)))
  139.       ;; Decide predicate: < or string-lessp
  140.       (if (numberp (car (car sort-lists))) ;Is a key numeric?
  141.       (setq predicate (function <))
  142.     (setq predicate (function string-lessp)))
  143.       (setq sort-lists
  144.         (sort sort-lists
  145.           (function
  146.            (lambda (a b)
  147.              (funcall predicate (car a) (car b))))))
  148.       (if reverse (setq sort-lists (nreverse sort-lists)))
  149.       ;; Now we enter critical region.  So, keyboard quit is disabled.
  150.       (message "Reordering messages...")
  151.       (let ((inhibit-quit t)        ;Inhibit quit
  152.         (current-message nil)
  153.         (msgnum 1)
  154.         (msginfo nil))
  155.     ;; There's little hope that we can easily undo after that.
  156.     (buffer-flush-undo (current-buffer))
  157.     (goto-char (rmail-msgbeg 1))
  158.     ;; To force update of all markers.
  159.     (insert-before-markers ?Z)
  160.     (backward-char 1)
  161.     ;; Now reorder messages.
  162.     (while sort-lists
  163.       (setq msginfo (car sort-lists))
  164.       ;; Swap two messages.
  165.       (insert-buffer-substring
  166.        (current-buffer) (nth 2 msginfo) (nth 3 msginfo))
  167.       (delete-region  (nth 2 msginfo) (nth 3 msginfo))
  168.       ;; Is current message?
  169.       (if (nth 1 msginfo)
  170.           (setq current-message msgnum))
  171.       (setq sort-lists (cdr sort-lists))
  172.       (if (zerop (% msgnum 10))
  173.           (message "Reordering messages...%d" msgnum))
  174.       (setq msgnum (1+ msgnum)))
  175.     ;; Delete the garbage inserted before.
  176.     (delete-char 1)
  177.     (setq quit-flag nil)
  178.     (buffer-enable-undo)
  179.     (rmail-set-message-counters)
  180.     (rmail-show-message current-message)))))
  181.  
  182. (defun rmail-fetch-field (msg field)
  183.   "Return the value of the header FIELD of MSG.
  184. Arguments are MSG and FIELD."
  185.   (save-restriction
  186.     (widen)
  187.     (let ((next (rmail-msgend msg)))
  188.       (goto-char (rmail-msgbeg msg))
  189.       (narrow-to-region (if (search-forward "\n*** EOOH ***\n" next t)
  190.                 (point)
  191.               (forward-line 1)
  192.               (point))
  193.             (progn (search-forward "\n\n" nil t) (point)))
  194.       (mail-fetch-field field))))
  195.  
  196. (defun rmail-make-date-sortable (date)
  197.   "Make DATE sortable using the function string-lessp."
  198.   ;; Assume the default time zone is GMT.
  199.   (timezone-make-date-sortable date "GMT" "GMT"))
  200.  
  201. (provide 'rmailsort)
  202.  
  203. ;;; rmailsort.el ends here
  204.